home *** CD-ROM | disk | FTP | other *** search
/ Celestin Apprentice 2 / Apprentice-Release2.iso / Tools / Languages / MacHaskell 2.2 / csys / dump-interface.scm < prev    next >
Encoding:
Text File  |  1994-09-27  |  10.9 KB  |  308 lines  |  [TEXT/CCL2]
  1. ;;;==================================================================
  2. ;;; Dump code generator
  3. ;;;==================================================================
  4.  
  5. (define (def-dump-index def)
  6.   (let ((code  (def-dump-code def)))
  7.     (cond ((not code)
  8.        (error "No dump code for def ~s." def))
  9.       ((and (pair? code)
  10.         (eq? (car code) 'def-n))
  11.        (cadr code))
  12.       (else
  13.        (error "Weird dump code for def ~s." def)))))
  14.  
  15. ;;; This saves slot initialization code.
  16.  
  17. (define (add-dump-init code)
  18.   (push code *dump-slot-init-code*))
  19.  
  20.  
  21. ;;; Here is the top-level call.
  22.  
  23. (define (create-dump-code unit modules load-prelude?)
  24.   (dynamic-let ((*unit* (module-unit (car modules)))
  25.         (*dump-defs*  '())
  26.         (*dump-types*  '())
  27.         (*dump-slot-init-code*  '())
  28.         (*dump-def-counter* 0)
  29.         (*dump-def-code-table* (make-table))
  30.         (*dump-file-names* '())
  31.         (*dump-type-counter* 0)
  32.         (*number-vars-dumped* 0)
  33.         (*number-types-dumped* 0)
  34.         (*number-classes-dumped* 0))
  35.     (let ((res (create-dump-code-aux unit modules load-prelude?)))
  36.       (when (memq 'dumper (dynamic *printers*))
  37.         (pprint* res))
  38.       (when (memq 'dump-stat (dynamic *printers*))
  39.     (format '#t
  40.       "~&Dumped ~A definitions, ~A type objects, and ~A classes.~%"
  41.           *number-vars-dumped* *number-types-dumped*
  42.       *number-classes-dumped*)
  43.     (format '#t "Used ~A definitions and ~A type cells.~%"
  44.         *dump-def-counter* *dump-type-counter*))
  45.       res)))
  46.  
  47. ;;; This assumes all modules are in the same compilation unit and that
  48. ;;; *unit* is set to that unit.
  49. ;;; imod-code establishes local bindings for all the imported modules.
  50. ;;; dmod-code establishes local bindings for all the modules defined in
  51. ;;; this compilation unit.
  52.  
  53. (define (create-dump-code-aux unit modules load-prelude?)
  54.   (let* ((imod-counter  0)
  55.      (imod-alist    '())
  56.      (explicit-imports (collect-all-imported-modules unit))
  57.      (all-imports   (if load-prelude?
  58.                 (append (collect-prelude-modules) explicit-imports)
  59.                 explicit-imports))
  60.      (imod-code     (map (lambda (m)
  61.                    (push (cons (module-name m) imod-counter)
  62.                      imod-alist)
  63.                    (incf imod-counter)
  64.                    `(locate-module ',(module-name m)))
  65.                  all-imports))
  66.      (dmod-counter  0)
  67.      (dmod-alist    '())
  68.      (dmod-code     (map (lambda (m)
  69.                    (push (cons (module-name m) dmod-counter)
  70.                      dmod-alist)
  71.                    (incf dmod-counter)
  72.                    `(make module
  73.                       (unit ',(module-unit m))
  74.                       (name ',(module-name m))
  75.                       (type ',(module-type m))))
  76.                  modules)))
  77.     ;; This actually does most of the work.  It dumps the module asts by
  78.     ;; placing inits for each slot into *dump-slot-init-code*.  A list of
  79.     ;; definitions referenced is maintained in *dump-defs*.
  80.     (dolist (m modules)
  81.       (dump-module m (cdr (assq (module-name m) dmod-alist))))
  82.     ;; This creates the final code
  83.     `(begin
  84.        (setf *writer-version* ',*haskell-compiler-version*)
  85.        (setf *modules-imported* (vector ,@imod-code))
  86.        (setf *modules-loaded* (vector ,@dmod-code))
  87.        ;; This sets the elements individually instead of using the vector
  88.        ;; function, because the vector may be longer than
  89.        ;; call-arguments-limit.
  90.        (setf *defs-referenced*
  91.          (make-vector ,(dynamic *dump-def-counter*)))
  92.        ,@(map (lambda (d) (make-def-init-code d imod-alist dmod-alist))
  93.           (nreverse *dump-defs*))
  94.        (setf *types-referenced*
  95.          (make-vector ,(dynamic *dump-type-counter*)))
  96.        ,@(map (lambda (n)
  97.         `(set-type-n ,(cdr n) ,(car n)))
  98.           (nreverse *dump-types*))
  99.        (setf *dump-file-names* ',*dump-file-names*)
  100.        ,@(dynamic *dump-slot-init-code*)
  101.        )
  102.     ))
  103.  
  104.  
  105.  
  106.  
  107. ;;; This computes the transitive closure of all modules available to
  108. ;;; a unit.
  109.  
  110. (define (collect-all-imported-modules unit)
  111.   (collect-all-modules-1 (ucache-imported-units unit) '() '()))
  112.  
  113. (define (collect-all-modules-1 units mods-so-far units-seen)
  114.   (cond ((null? units)
  115.      mods-so-far)
  116.     ((mem-string (car units) units-seen)
  117.      (collect-all-modules-1 (cdr units) mods-so-far units-seen))
  118.     (else
  119.      (let ((u (lookup-compilation-unit (car units))))
  120.        (collect-all-modules-1
  121.         (append (ucache-imported-units u) (cdr units))
  122.         (append (ucache-modules u) mods-so-far)
  123.         (cons (ucache-ufile u) units-seen))))
  124.     ))
  125.  
  126. (define (collect-prelude-modules)
  127.   (let ((prelude-unit (lookup-compilation-unit *prelude-unit-filename*)))
  128.     (append (ucache-modules prelude-unit)
  129.         (collect-all-imported-modules prelude-unit))))
  130.  
  131.  
  132.  
  133. ;;; This code returns the load time definition for an object.  When the
  134. ;;; object is a core symbol or in a different unit, previously
  135. ;;; created definitions are returned.  Otherwise, a new definition is
  136. ;;; created.
  137.   
  138. (define (make-def-init-code d imod-alist dmod-alist)
  139.   (when (def-forward-to d)         ;; If the definition came from an
  140.      (setf d (def-forward-to d)))  ;; interface forward to to the real def
  141.   (cond ((def-prelude? d)
  142.      ;; Core symbols should never have an entry in *defs-referenced*.
  143.      ;; See with-new-def.
  144.      (error "Bad core symbol ~s in *defs-referenced*." d))
  145.     ((eq? (def-unit d) *unit*)
  146.      `(,(cond ((method-var? d) 'set-def-n/method-var)
  147.           ((var? d) 'set-def-n/var)
  148.           ((con? d) 'set-def-n/con)
  149.           ((synonym? d) 'set-def-n/synonym)
  150.           ((algdata? d) 'set-def-n/algdata)
  151.           ((class? d) 'set-def-n/class)
  152.           ((is-type? 'deriving d) 'set-def-n/deriving))
  153.        ,(def-dump-index d)
  154.        ,(or (cdr (assq (def-module d) dmod-alist))
  155.         ;; This can happen if we have a forward reference to
  156.         ;; a def imported from another compilation unit.
  157.         `',(def-module d))
  158.        ',(def-name d)))
  159.     ((is-tuple-constructor? d)
  160.      `(set-def-n/tuple-con
  161.        ,(def-dump-index d)
  162.        ,(tuple-constructor-arity d)))
  163.     ((is-tuple-tycon? d)
  164.      `(set-def-n/tuple-tycon
  165.        ,(def-dump-index d)
  166.        ,(tuple-constructor-arity (car (algdata-constrs d)))))
  167.     (else
  168.      (let ((m (assq (def-module d) imod-alist)))
  169.        ;; This is a bogus error message.  The problem is that nothing
  170.        ;; so far ensures units are closed under import/export: some
  171.        ;; modules may be referenced that are accidentally in the symbol
  172.        ;; table.  The unit file for the current module needs to be
  173.        ;; updated when this happens.
  174.        (when (eq? m '#f)
  175.          (fatal-error 'symbol-not-in-unit
  176.  "Reference to symbol ~A in module ~A: not in compilation unit.~%"
  177.                 (def-name d) (def-module d)))
  178.        `(set-def-n/import
  179.          ,(def-dump-index d)
  180.          ,(cdr m)
  181.          ',(def-name d))))
  182.     ))
  183.  
  184.  
  185. ;;; Once a module has been compiled, most of its slots are useless.
  186. ;;; All we really need to save are the identifying information,
  187. ;;; symbol table, and export table.
  188. ;;; Instances also need to be dumped here instead of with class objects;
  189. ;;; this is because links can go across compilation unit boundaries.
  190. ;;; They are fixed up when pulling units out of the cache.
  191. ;;; The identifying info is stored when the module variable is bound.
  192.  
  193.  
  194. (define (dump-module module index)
  195.   (let ((mod-exp `(lookup-defined-mod ,index))
  196.     (save-all-symbols (or (eq? (module-type module) 'standard)
  197.                   (eq? (module-type module) 'interface)
  198.                   (eq? (module-name module) '|Prelude|))))
  199.     ;; Dump symbol table entries only for defs for which this is
  200.     ;; the "home" module.  (In other words, ignore imported defs.)
  201.     ;; The purpose of this is to allow references from other
  202.     ;; interface files to be resolved; see make-def-init-code.
  203.     ;; Jcp: we need to save the complete symbol table for incremental
  204.     ;; compilation to work.
  205.     (let ((code  '())
  206.       (defs  '()))
  207.       (table-for-each
  208.         (lambda (key val)
  209.       (when (or save-all-symbols
  210.             (eq? (def-module val) (module-name module)))
  211.         (let ((stuff  (dump-object val)))
  212.           (if (def-prelude? val)
  213.           (if (eq? key (def-name val))
  214.               (push `(set-symtab/def tab ,stuff) code)
  215.               (push `(set-symtab/def/key tab ,stuff ',key) code))
  216.           (if (eq? key (def-name val))
  217.               (push (def-dump-index val) defs)
  218.               (push `(set-symtab/def-n/key
  219.                    tab ,(def-dump-index val) ',key)
  220.                 code))))))
  221.     (module-symbol-table module))
  222.       (add-dump-init `(setf (module-symbol-table ,mod-exp)
  223.                 (let ((tab  (make-table)))
  224.                   (set-symtab/def-n/list tab ',defs)
  225.                   ,@code
  226.                   tab))))
  227.     ;; dump the fixity table - needed by the incremental compiler
  228.     (when save-all-symbols
  229.       (let ((data  '()))
  230.     (table-for-each
  231.       (lambda (key val)
  232.         (let ((ass   (fixity-associativity val))
  233.           (prec  (fixity-precedence val)))
  234.           (push (list key ass prec) data)))
  235.       (module-fixity-table module))
  236.     (add-dump-init `(setf (module-fixity-table ,mod-exp)
  237.                   (make-fixity-table ',data)))))
  238.     ;; Save the definition point of the module
  239.     (mlet (((file line) (dump-source-pointer (ast-node-line-number module))))
  240.        (add-dump-init `(setf (ast-node-line-number ,mod-exp)
  241.                  (restore-source-pointer ',file ',line))))
  242.     ;; Dump all export table entries.  This is used by the import/export
  243.     ;; phase to resolve references.  
  244.     (let ((code  '())
  245.       (defs  '()))
  246.       (table-for-each
  247.         (lambda (key val)
  248.       ;; val is an a-list of (sym . def) pairs.
  249.       ;; Look for shortcut to reduce size of generated code.
  250.       (if (and (null? (cdr val))
  251.            (eq? (car (car val)) key))
  252.           (let* ((def    (cdr (car val)))
  253.              (stuff  (dump-object def)))
  254.         (if (def-prelude? def)
  255.             (if (eq? key (def-name def))
  256.             (push `(set-export/def tab ,stuff) code)
  257.             (push `(set-export/def/key tab stuff ',key) code))
  258.             (if (eq? key (def-name def))
  259.             (push (def-dump-index def) defs)
  260.             (push `(set-export/def-n/key
  261.                  tab ,(def-dump-index def) ',key)
  262.                   code))))
  263.           (push `(setf (table-entry tab ',key) ,(dump-object val))
  264.             code)))
  265.     (module-export-table module))
  266.       (add-dump-init `(setf (module-export-table ,mod-exp)
  267.                 (let ((tab  (make-table)))
  268.                   (set-export/def-n/list tab ',defs)
  269.                   ,@code
  270.                   tab))))
  271.     ;; Dump the instances.
  272.     (add-dump-init `(setf (module-instance-defs ,mod-exp)
  273.               ,(dump-object (module-instance-defs module))))
  274.     (add-dump-init `(setf (module-default ,mod-exp)
  275.               ,(dump-object (module-default module))))
  276.     (add-dump-init `(setf (module-uses-standard-prelude? ,mod-exp)
  277.               ,(dump-object
  278.                 (module-uses-standard-prelude? module))))
  279.     (add-dump-init `(setf (module-interface-definitions ,mod-exp)
  280.               (list ,@(map (function dump-interface-definitions)
  281.                        (module-interface-definitions module)))))
  282.     (add-dump-init `(setf (module-unresolved-symbols ,mod-exp)
  283.               ,(dump-object (module-unresolved-symbols module))))
  284.     (add-dump-init `(setf (module-stand-alone? ,mod-exp)
  285.               ,(dump-object (module-stand-alone? module))))
  286.     ))
  287.  
  288.  
  289. ;;; It looks to me like core-symbols never appear in the 
  290. ;;; module-interface-definitions lists (see top/symbol-table.scm).
  291.  
  292. (define (dump-interface-definitions entry)
  293.   (let ((module-name (car entry))
  294.     (defs        (cdr entry)))
  295.     `(interface-def/n
  296.        ',module-name
  297.        ',(map (lambda (d)
  298.         (let ((stuff  (dump-object d)))
  299.           (declare (ignore stuff))
  300.           (if (def-prelude? d)
  301.               (error "Hey!  Core symbols not allowed here!")
  302.               (def-dump-index d))))
  303.           defs))
  304.     ))
  305.  
  306.  
  307.  
  308.